home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PASCALL / NEETVGA / RGB / FERN2.PAS < prev    next >
Pascal/Delphi Source File  |  1993-02-13  |  5KB  |  166 lines
  1. {****************************************************************************}
  2. {***********************                              ***********************}
  3. {**                           R-G-B Demonstrator                           **}
  4. {****************************                    ****************************}
  5. {**                       Copyrighted February 12, 1993                    **}
  6. {**                       (C) To Authors                                   **}
  7. {**                             Fernando Padilla                           **}
  8. {**                             Stephen Markham                            **}
  9. {******************************                ******************************}
  10. {****************************************************************************}
  11.  
  12. uses
  13.      roger,crt;
  14. const
  15.      pause=15;
  16.      bottom=0;
  17.      base=15;
  18.      top=63;
  19. type
  20.      pRGB=(R,RRG,RG,RGG,G,GGB,GB,GBB,B,BBR,BR,BRR,W);
  21.      cRGB=record
  22.           color,
  23.           red,
  24.           green,
  25.           blue:byte;
  26.      end;
  27.  
  28. procedure updatergb(a,b,c,d:integer);
  29. begin
  30.      textcolor(1);
  31.      gotoxy(1,1);
  32.       write('Color:');
  33.       writeln(a:14);
  34.      gotoxy(1,3);
  35.       write('RED:');
  36.       writeln(b:16);
  37.      gotoxy(1,4);
  38.       write('GREEN:');
  39.       writeln(c:14);
  40.      gotoxy(1,5);
  41.       write('BLUE:');
  42.       writeln(d:15);
  43. end;
  44.  
  45. function inverse(a,b:integer):integer;
  46. begin
  47.      inverse:=abs(a-b);
  48. end;
  49.  
  50. Procedure saycolor(a,b,c,d:integer;  updat:boolean);
  51.   function rat(percent,high:byte):integer;
  52.   begin
  53.        rat:=trunc(high*(percent/100));
  54.   end;
  55.   function inverse(a,b:integer):integer;
  56.   begin
  57.        inverse:=abs(a-b);
  58.   end;
  59. begin
  60.      PutColor(a,rat(b,top),rat(c,top),rat(d,top));
  61.      PutColor(a+1,inverse(rat(b,top),top),inverse(rat(c,top),top),inverse(rat(d,top),top));
  62.      if updat then UpdateRGB(a,b,c,d);
  63. end;
  64.  
  65. procedure raise(var c:byte);
  66. begin
  67.      if c<100 then inc(c);
  68. end;
  69.  
  70. procedure lower(var c:byte);
  71. begin
  72.      if c>0 then dec(c);
  73. end;
  74.  
  75. Procedure ControlColor(var rgb:crgb;  var stop:boolean;  command:char);
  76. begin
  77.      if not stop then
  78.      begin
  79.           with rgb do case command of
  80.                '7': raise(red);
  81.                '8': raise(green);
  82.                '9': raise(blue);
  83.  
  84.                '1': lower(red);
  85.                '2': lower(green);
  86.                '3': lower(blue);
  87.                #27: stop:=true;
  88.                else
  89.           end;
  90.      end;
  91. end;
  92.  
  93.  
  94. procedure control1(display:boolean);
  95. var
  96.      palette:rogerrgbpalette;
  97.      color:prgb;
  98.      stop:boolean;
  99.   Procedure FadeColor(c:pRGB;  display:boolean;  var stop:boolean);
  100.   var
  101.       i:integer;
  102.     Procedure DoColor(c:pRGB;  i:integer;  var display,stop:boolean);
  103.     Begin
  104.          if not stop then
  105.          begin
  106.               Case c of
  107.                    R: SayColor(0,i,0,0,display);
  108.                  RRG: SayColor(0,i,i div 2,0,display);
  109.                   RG: SayColor(0,i,i,0,display);
  110.                  RGG: SayColor(0,i div 2,i,0,display);
  111.                    G: SayColor(0,0,i,0,display);
  112.                  GGB: SayColor(0,0,i,i div 2,display);
  113.                   GB: SayColor(0,0,i,i,display);
  114.                  GBB: SayColor(0,0,i div 2,i,display);
  115.                    B: SayColor(0,0,0,i,display);
  116.                  BBR: SayColor(0,i div 2,0,i,display);
  117.                   BR: SayColor(0,i,0,i,display);
  118.                  BRR: SayColor(0,i,0,i div 2,display);
  119.                    W: SayColor(0,i,i,i,display);
  120.               end;
  121.               delay(pause);
  122.               stop:=keypressed;
  123.          end;
  124.     end;
  125.   Begin
  126.        if not stop then
  127.        begin
  128.             For i := 0 To 100 Do Docolor(c,i,display,stop);
  129.             For i := 100 DownTo 0 Do Docolor(c,i,display,stop);
  130.        end;
  131.   end;
  132. Begin
  133.      store(palette);
  134.      stop:=false;
  135.      Repeat
  136.        for color:=R to W do FadeColor(color,display,stop);
  137.      Until KeyPressed or stop;
  138.      Restore(palette);
  139. End;
  140.  
  141. procedure control2(display:boolean);
  142. var
  143.      palette:rogerrgbpalette;
  144.      c:crgb;
  145.      stop:boolean;
  146. Begin
  147.      store(palette);
  148.      stop:=false;
  149.      c.color:=0;
  150.      c.red:=0;
  151.      c.green:=0;
  152.      c.blue:=0;
  153.      Repeat
  154.           controlcolor(c,stop,readkey);
  155.           with c do saycolor(color,red,green,blue,display);
  156.      Until stop;
  157.      Restore(palette);
  158. End;
  159.  
  160.  
  161. begin
  162.      clrscr;
  163.      window(30,11,51,17);
  164.      control1(not(pos('false',paramstr(1))>0));
  165.      control2(not(pos('false',paramstr(1))>0));
  166. end.